home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / tforth21.lha / tile-forth-2.1 / lib / relations.f83 < prev    next >
Text File  |  1991-09-14  |  5KB  |  206 lines
  1. \
  2. \  RELATION MANAGEMENT LIBRARY
  3. \
  4. \  Copyright (C) 1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 8 August 1990
  15. \
  16. \  Last updated on: 20 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, structures, blocks
  20. \
  21. \  Description:
  22. \       Management of relations represented as association lists. Relations
  23. \       may be defined between items as a triple: (item X relation X value)
  24. \       Supports iteration over the item set, the relations of an item, and
  25. \       the relations and values of an item.
  26. \
  27. \  Copying:
  28. \       This program is free software; you can redistribute it and\or modify
  29. \       it under the terms of the GNU General Public License as published by
  30. \       the Free Software Foundation; either version 1, or (at your option)
  31. \       any later version.
  32. \
  33. \       This program is distributed in the hope that it will be useful,
  34. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  35. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  36. \       GNU General Public License for more details.
  37. \
  38. \       You should have received a copy of the GNU General Public License
  39. \       along with this program; see the file COPYING.  If not, write to
  40. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  41.  
  42. .( Loading Relations definitions...) cr
  43.  
  44. #include structures.f83
  45. #include blocks.f83
  46.  
  47. vocabulary relations ( -- )
  48.  
  49. blocks structures relations definitions
  50.  
  51. \ Item creation, entry mapping and display function
  52.  
  53. variable items ( -- addr) 
  54.  
  55. nil items !
  56.  
  57. struct.type ITEM ( entry -- )
  58.   ptr +next-item ( item -- addr) private
  59.   ptr +entry ( item -- addr) private
  60.   ptr +associations ( item -- addr) private
  61. struct.init ( entry item -- ) 
  62.   tuck +entry !
  63.   nil over +associations !
  64.   items @ over +next-item !
  65.   items !
  66. struct.end
  67.  
  68. : new-item ( -- item)
  69.   nil new-struct ITEM
  70. ;
  71.  
  72. : item ( -- )
  73.   create last new-struct ITEM drop
  74. ;
  75.  
  76. : this-item ( -- item)
  77.   last >body
  78. ;
  79.  
  80. : item>entry ( item -- entry)
  81.   +entry @
  82. ;
  83.  
  84. : .item ( item -- )
  85.   dup item>entry ?dup if .name drop else ." item#" 0 .r then
  86. ;
  87.  
  88. \ Association creation, and search function
  89.  
  90. struct.type ASSOCIATION ( value relatin next -- ) private
  91.   ptr +next-association ( association -- addr) private
  92.   ptr +relation ( association -- addr) private
  93.   ptr +value ( association -- addr) private
  94. struct.init ( value relation next association -- )
  95.   dup >r +next-association ! r@ +relation ! r> +value !
  96. struct.end
  97.  
  98. : associate ( relation association -- addr)
  99.   ?dup
  100.   if 2dup +relation @ =
  101.     if nip +value
  102.     else +next-association @ tail-recurse then
  103.   else 
  104.     drop nil
  105.   then
  106. ; private
  107.  
  108. \ Relation access and assign functions
  109.  
  110. : put-relation ( value relation item -- )
  111.   +associations 2dup @ associate ?dup
  112.   if >r 2drop r> !
  113.   else
  114.     dup >r +next-association @ new-struct ASSOCIATION r> !
  115.   then
  116. ;
  117.  
  118. : get-relation ( relation item -- value)
  119.   +associations @ associate @
  120. ;
  121.  
  122. : ?get-relation ( relation item -- [relation item false] or [value true])
  123.   2dup +associations @ associate dup if >r 2drop r> @ true then
  124. ;
  125.  
  126. : ?avail-relation ( relation item -- bool)
  127.   +associations @ associate boolean
  128. ;
  129.  
  130. : ?is-relation ( value relation item -- bool)
  131.   +associations @ associate ?dup if @ = else drop false then
  132. ;
  133.  
  134. : remove-relation ( relation item -- )
  135.   swap >r +associations
  136.   begin
  137.     dup +next-association @ ?dup
  138.   while
  139.     dup +relation @ r@ =
  140.     if +next-association @ swap +next-association !
  141.       r> drop exit
  142.     then
  143.     nip
  144.   repeat
  145.   drop
  146. ;
  147.  
  148. \ Item set iterators
  149.  
  150. : map-items ( block[item -- ] -- )
  151.   >r items @
  152.   begin
  153.     ?dup
  154.   while
  155.     r@ over >r
  156.     call
  157.     r> +next-item @
  158.   repeat
  159.   r> drop
  160. ;
  161.  
  162. : map-relation ( relation block[value item -- ] -- )
  163.   >r items @
  164.   begin
  165.     ?dup
  166.   while
  167.     2dup ?get-relation 
  168.     if swap rot r@ swap >r over >r 
  169.       call
  170.       r> r> swap 
  171.     else
  172.       2drop
  173.     then
  174.     +next-item @
  175.   repeat
  176.   r> 2drop
  177. ;
  178.  
  179. : map-item ( item block[value relation -- ] -- )
  180.   >r +associations @
  181.   begin
  182.     ?dup
  183.   while
  184.     dup +value @ over +relation @ rot r@ swap >r
  185.     call
  186.     r> +next-association @
  187.   repeat
  188.   r> drop
  189. ;
  190.   
  191. \ Item set display functions
  192.  
  193. : .items ( -- )
  194.   ." items: " block[ .item space ]; map-items
  195. ;
  196.  
  197. : .relations ( item -- )
  198.   dup .item ." :relations: " block[ .item space drop ]; map-item
  199. ;
  200.  
  201. : .values ( item -- )
  202.   dup .item ." :values: " block[ .item ." : " . ]; map-item
  203. ;
  204.  
  205. forth only
  206.